home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / clisp-c.zoo / defmacro.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1993-06-05  |  28.5 KB  |  616 lines
  1. ;;;; File DEFMACRO.LSP
  2. ;;; Macro DEFMACRO und einige Hilfsfunktionen für komplizierte Macros.
  3. ;;; 1. 9. 1988
  4. ;;; Adaptiert an DEFTYPE am 10.6.1989
  5.  
  6. (in-package "SYSTEM")
  7.  
  8. ;; Import aus CONTROL.Q:
  9.  
  10. #| (SYSTEM::PARSE-BODY body &optional docstring-allowed env)
  11.    expandiert die ersten Formen in der Formenliste body (im Function-
  12.    Environment env), entdeckt dabei auftretende Deklarationen (und falls
  13.    docstring-allowed=T, auch einen Docstring) und liefert drei Werte:
  14.    1. body-rest, die restlichen Formen,
  15.    2. declspec-list, eine Liste der aufgetretenen Decl-Specs,
  16.    3. docstring, ein aufgetretener Docstring oder NIL.
  17. |#
  18. #| (SYSTEM::KEYWORD-TEST arglist kwlist)
  19.    testet, ob arglist (eine paarige Keyword/Value-Liste) nur Keywords
  20.    enthält, die auch in der Liste kwlist vorkommen, oder aber ein
  21.    Keyword/Value-Paar :ALLOW-OTHER-KEYS mit Value /= NIL enthält.
  22.    Wenn nein, wird ein Error ausgelöst.
  23. |#
  24. #| (keyword-test arglist kwlist) überprüft, ob in arglist (eine Liste
  25. von Keyword/Value-Paaren) nur Keywords vorkommen, die in kwlist vorkommen,
  26. oder ein Keyword/Value-Paar mit Keyword = :ALLOW-OTHER-KEYS und Value /= NIL
  27. vorkommt. Sollte dies nicht der Fall sein, wird eine Errormeldung ausgegeben.
  28.  
  29. (defun keyword-test (arglist kwlist)
  30.   (let ((unallowed-arglistr nil)
  31.         (allow-other-keys-flag nil))
  32.     (do ((arglistr arglist (cddr arglistr)))
  33.         ((null arglistr))
  34.       (if (eq (first arglistr) ':ALLOW-OTHER-KEYS)
  35.           (if (second arglistr) (setq allow-other-keys-flag t))
  36.           (do ((kw (first arglistr))
  37.                (kwlistr kwlist (cdr kwlistr)))
  38.               ((or (null kwlistr) (eq kw (first kwlistr)))
  39.                (if (and (null kwlistr) (null unallowed-arglistr))
  40.                    (setq unallowed-arglistr arglistr)
  41.     ) )   )   ))
  42.     (unless allow-other-keys-flag
  43.       (if unallowed-arglistr
  44.         (cerror #+DEUTSCH "Beide werden übergangen."
  45.                 #+ENGLISH "It will be ignored."
  46.                 #+FRANCAIS "Ignorer les deux."
  47.                 #+DEUTSCH "Unzulässiges Keyword ~S mit Wert ~S"
  48.                 #+ENGLISH "Invalid keyword-value-pair: ~S ~S"
  49.                 #+FRANCAIS "Mot-clé illégal ~S, valeur ~S"
  50.                 (first unallowed-arglistr) (second unallowed-arglistr)
  51.     ) ) )
  52. ) )
  53. ; Definition in Assembler siehe CONTROL.Q
  54. |#
  55.  
  56. (defun macro-call-error (macro-form)
  57.   (error #+DEUTSCH "Der Macro ~S kann nicht mit ~S Argumenten aufgerufen werden: ~S"
  58.          #+ENGLISH "The macro ~S may not be called with ~S arguments"
  59.          #+FRANCAIS "Le macro ~S ne peut pas être appelé avec ~S arguments : ~S"
  60.          (car macro-form) (1- (length macro-form)) macro-form
  61. ) )
  62.  
  63. (proclaim '(special
  64.         %restp ; gibt an, ob &REST/&BODY/&KEY angegeben wurde,
  65.                ; also ob die Argumentanzahl unbeschränkt ist.
  66.  
  67.         %min-args ; gibt die Anzahl der notwendigen Argumente an
  68.  
  69.         %arg-count ; gibt die Anzahl der Einzelargumente an
  70.                    ; (notwendige und optionale Argumente, zusammengezählt)
  71.  
  72.         %let-list ; umgedrehte Liste der Bindungen, die mit LET* zu machen sind
  73.  
  74.         %keyword-tests ; Liste der KEYWORD-TEST - Aufrufe, die einzubinden sind
  75.  
  76.         %default-form ; Default-Form für optionale und Keyword-Argumente,
  77.                    ; bei denen keine Default-Form angegeben ist.
  78.                    ; =NIL normalerweise, = (QUOTE *) für DEFTYPE.
  79. )          )
  80. #|
  81. (ANALYZE1 lambdalist accessexp name wholevar)
  82. analysiert eine Macro-Lambdaliste (ohne &ENVIRONMENT). accessexp ist der
  83. Ausdruck, der die Argumente liefert, die mit dieser Lambdaliste zu matchen
  84. sind.
  85.  
  86. (ANALYZE-REST lambdalistr restexp name)
  87. analysiert den Teil einer Macro-Lambdaliste, der nach &REST/&BODY kommt.
  88. restexp ist der Ausdruck, der die Argumente liefert, die mit diesem
  89. Listenrest zu matchen sind.
  90.  
  91. (ANALYZE-KEY lambdalistr restvar name)
  92. analysiert den Teil einer Macro-Lambdaliste, der nach &KEY kommt.
  93. restvar ist das Symbol, das die restlichen Argumente enthalten wird.
  94.  
  95. (ANALYZE-AUX lambdalistr name) 
  96. analysiert den Teil einer Macro-Lambdaliste, der nach &AUX kommt.
  97.  
  98. (REMOVE-ENV-ARG lambdalist name)
  99. entfernt das Paar &ENVIRONMENT/Symbol aus einer Macro-Lambdaliste,
  100. liefert zwei Werte: die verkürzte Lambdaliste und das als Environment zu
  101. verwendende Symbol (oder die Lambdaliste selbst und NIL, falls &ENVIRONMENT
  102. nicht auftritt).
  103.  
  104. (MAKE-LENGTH-TEST symbol)
  105. kreiert aus %restp, %min-args, %arg-count eine Testform, die bei Auswertung
  106. anzeigt, ob der Inhalt der Variablen symbol als Aufruferform zum Macro
  107. dienen kann.
  108.  
  109. (MAKE-MACRO-EXPANSION macrodef)
  110. liefert zu einer Macrodefinition macrodef = (name lambdalist . body)
  111. 1. den Macro-Expander als Programmtext (FUNCTION ... (LAMBDA ...)),
  112. 2. name, ein Symbol,
  113. 3. lambdalist,
  114. 4. docstring (oder NIL, wenn keiner da).
  115. |#
  116.  
  117. (%proclaim-constant 'macro-missing-value (list 'macro-missing-value))
  118. ; einmaliges Objekt
  119.  
  120. (%putd 'analyze-aux
  121.   (function analyze-aux
  122.     (lambda (lambdalistr name)
  123.       (do ((listr lambdalistr (cdr listr)))
  124.           ((atom listr)
  125.            (if listr
  126.              (cerror #+DEUTSCH "Der Teil danach wird ignoriert."
  127.                      #+ENGLISH "The rest of the lambda list will be ignored."
  128.                      #+FRANCAIS "Ignorer ce qui suit."
  129.                      #+DEUTSCH "Die Lambdaliste des Macros ~S enthält einen Punkt nach &AUX."
  130.                      #+ENGLISH "The lambda list of macro ~S contains a dot after &AUX."
  131.                      #+FRANCAIS "La liste lambda du macro ~S contient un point après &AUX."
  132.                      name
  133.           )) )
  134.         (cond ((symbolp (car listr)) (setq %let-list (cons `(,(car listr) nil) %let-list)))
  135.               ((atom (car listr))
  136.                (error #+DEUTSCH "Im Macro ~S ist als &AUX-Variable nicht verwendbar: ~S"
  137.                       #+ENGLISH "in macro ~S: ~S may not be used as &AUX variable."
  138.                       #+FRANCAIS "Dans le macro ~S, l'utilisation de ~S n'est pas possible comme variable &AUX."
  139.                       name (car listr)
  140.               ))
  141.               (t (setq %let-list
  142.                    (cons `(,(caar listr) ,(cadar listr)) %let-list)
  143.   ) ) ) )     )  )
  144. )
  145.  
  146. (%putd 'analyze-key
  147.   (function analyze-key
  148.     (lambda (lambdalistr restvar name &aux (otherkeysforbidden t) (kwlist nil))
  149.       (do ((listr lambdalistr (cdr listr))
  150.            (next)
  151.            (kw)
  152.            (svar)
  153.            (g))
  154.           ((atom listr)
  155.            (if listr
  156.              (cerror #+DEUTSCH "Der Teil danach wird ignoriert."
  157.                      #+ENGLISH "The rest of the lambda list will be ignored."
  158.                      #+FRANCAIS "Ignorer ce qui suit."
  159.                      #+DEUTSCH "Die Lambdaliste des Macros ~S enthält einen Punkt nach &KEY."
  160.                      #+ENGLISH "The lambda list of macro ~S contains a dot after &KEY."
  161.                      #+FRANCAIS "La liste lambda du macro ~S contient un point après &KEY."
  162.                      name
  163.           )) )
  164.         (setq next (car listr))
  165.         (cond ((eq next '&ALLOW-OTHER-KEYS) (setq otherkeysforbidden nil))
  166.               ((eq next '&AUX) (return-from nil (analyze-aux (cdr listr) name)))
  167.               ((or (eq next '&ENVIRONMENT) (eq next '&WHOLE) (eq next '&OPTIONAL)
  168.                    (eq next '&REST) (eq next '&BODY) (eq next '&KEY)
  169.                )
  170.                (cerror #+DEUTSCH "Es wird ignoriert."
  171.                        #+ENGLISH "It will be ignored."
  172.                        #+FRANCAIS "Ignorer ce qui suit."
  173.                        #+DEUTSCH "Die Lambdaliste des Macros ~S enthält ein ~S an falscher Stelle."
  174.                        #+ENGLISH "The lambda list of macro ~S contains a badly placed ~S."
  175.                        #+FRANCAIS "La liste lambda du macro ~S contient un ~S mal placé."
  176.                        name next
  177.               ))
  178.               (t
  179.                 (if %default-form
  180.                   (cond ((symbolp next) (setq next (list next %default-form)))
  181.                         ((and (consp next) (eql (length next) 1))
  182.                          (setq next (list (car next) %default-form))
  183.                 ) )     )
  184.                 (cond ((symbolp next)
  185.                        (setq kw (intern (symbol-name next) *keyword-package*))
  186.                        (setq %let-list
  187.                          (cons `(,next (GETF ,restvar ,kw NIL)) %let-list)
  188.                        )
  189.                        (setq kwlist (cons kw kwlist))
  190.                       )
  191.                       ((atom next)
  192.                        (cerror #+DEUTSCH "Es wird ignoriert."
  193.                                #+ENGLISH "It will be ignored."
  194.                                #+FRANCAIS "Il sera ignoré."
  195.                                #+DEUTSCH "Die Lambdaliste des Macros ~S enthält folgendes unpassende Element: ~S"
  196.                                #+ENGLISH "The lambda list of macro ~S contains the invalid element ~S"
  197.                                #+FRANCAIS "La liste lambda du macro ~S contient cet élément inadmissible : ~S"
  198.                                name next
  199.                       ))
  200.                       ((symbolp (car next))
  201.                        (setq kw (intern (symbol-name (car next)) *keyword-package*))
  202.                        (setq %let-list
  203.                          (cons `(,(car next) (GETF ,restvar ,kw MACRO-MISSING-VALUE))
  204.                                %let-list
  205.                        ) )
  206.                        (setq svar (if (and (cddr next) (symbolp (third next)))
  207.                                     (third next)
  208.                                     nil
  209.                        )          )
  210.                        (setq %let-list
  211.                          (cons
  212.                            (if svar
  213.                              `(,svar (IF (EQ ,(car next) MACRO-MISSING-VALUE)
  214.                                        (PROGN (SETQ ,(car next) ,(cadr next)) NIL)
  215.                                        T
  216.                               )      )
  217.                              `(,(car next) (IF (EQ ,(car next) MACRO-MISSING-VALUE)
  218.                                              ,(cadr next)
  219.                                              ,(car next)
  220.                               )            )
  221.                            )
  222.                            %let-list
  223.                        ) )
  224.                        (setq kwlist (cons kw kwlist))
  225.                       )
  226.                       ((not (and (consp (car next)) (keywordp (caar next)) (consp (cdar next))))
  227.                        (cerror #+DEUTSCH "Es wird ignoriert."
  228.                                #+ENGLISH "It will be ignored."
  229.                                #+FRANCAIS "Elle sera ignorée."
  230.                                #+DEUTSCH "Die Lambdaliste des Macros ~S enthält eine unzulässige Keywordspezifikation: ~S"
  231.                                #+ENGLISH "The lambda list of macro ~S contains an invalid keyword specification ~S"
  232.                                #+FRANCAIS "La liste lambda du macro ~S contient une spécification de mot-clé inadmissible : ~S"
  233.                                name (car next)
  234.                       ))
  235.                       ((symbolp (cadar next))
  236.                        (setq kw (caar next))
  237.                        (setq %let-list
  238.                          (cons `(,(cadar next) (GETF ,restvar ,kw MACRO-MISSING-VALUE))
  239.                            %let-list
  240.                        ) )
  241.                        (setq svar (if (and (cddr next) (symbolp (third next)))
  242.                                     (third next)
  243.                                     nil
  244.                        )          )
  245.                        (setq %let-list
  246.                          (cons
  247.                            (if svar
  248.                              `(,svar (IF (EQ ,(cadar next) MACRO-MISSING-VALUE)
  249.                                        (PROGN (SETQ ,(cadar next) ,(cadr next)) NIL)
  250.                                        T
  251.                               )      )
  252.                              `(,(cadar next) (IF (EQ ,(cadar next) MACRO-MISSING-VALUE)
  253.                                              ,(cadr next)
  254.                                              ,(cadar next)
  255.                               )            )
  256.                            )
  257.                            %let-list
  258.                        ) )
  259.                        (setq kwlist (cons kw kwlist))
  260.                       )
  261.                       (t
  262.                        (setq kw (caar next))
  263.                        (setq g (gensym))
  264.                        (setq %let-list
  265.                          (cons `(,g (GETF ,restvar ,kw MACRO-MISSING-VALUE)) %let-list)
  266.                        )
  267.                        (setq svar (if (and (cddr next) (symbolp (third next)))
  268.                                     (third next)
  269.                                     nil
  270.                        )          )
  271.                        (setq %let-list
  272.                          (cons
  273.                            (if svar
  274.                              `(,svar (IF (EQ ,g MACRO-MISSING-VALUE)
  275.                                        (PROGN (SETQ ,g ,(cadr next)) NIL)
  276.                                        T
  277.                               )      )
  278.                              `(,g (IF (EQ ,g MACRO-MISSING-VALUE)
  279.                                     ,(cadr next)
  280.                                     ,(cadar next)
  281.                               )   )
  282.                            )
  283.                            %let-list
  284.                        ) )
  285.                        (setq kwlist (cons kw kwlist))
  286.                        (let ((%min-args 0) (%arg-count 0) (%restp nil) (%default-form nil))
  287.                          (analyze1 (cadar next) g name g)
  288.                       ))
  289.               ) )
  290.       ) )
  291.       (if otherkeysforbidden
  292.         (setq %keyword-tests
  293.           (cons `(KEYWORD-TEST ,restvar ',kwlist) %keyword-tests)
  294.       ) )
  295.   ) )
  296. )
  297.  
  298. (%putd 'analyze-rest
  299.   (function analyze-rest
  300.     (lambda (lambdalistr restexp name)
  301.       (if (atom lambdalistr)
  302.         (error #+DEUTSCH "Die Lambdaliste des Macros ~S enthält keine Variable nach &REST/&BODY."
  303.                #+ENGLISH "The lambda list of macro ~S is missing a variable after &REST/&BODY."
  304.                #+FRANCAIS "Il manque une variable après &REST/BODY dans la liste lambda du macro ~S."
  305.                name
  306.       ) )
  307.       (unless (symbolp (car lambdalistr))
  308.         (error #+DEUTSCH "Die Lambdaliste des Macros ~S enthält eine unzulässige Variable nach &REST/&BODY: ~S"
  309.                #+ENGLISH "The lambda list of macro ~S contains an illegal variable after &REST/&BODY: ~S"
  310.                #+FRANCAIS "La liste lambda du macro ~S contient une variable indamissible après &REST/BODY : ~S"
  311.                name (car lambdalistr)
  312.       ) )
  313.       (let ((restvar (car lambdalistr))
  314.             (listr (cdr lambdalistr)))
  315.         (setq %restp t)
  316.         (setq %let-list (cons `(,restvar ,restexp) %let-list))
  317.         (cond ((null listr))
  318.               ((atom listr)
  319.                (cerror #+DEUTSCH "Der Teil danach wird ignoriert."
  320.                        #+ENGLISH "The rest of the lambda list will be ignored."
  321.                        #+FRANCAIS "Ignorer ce qui suit."
  322.                        #+DEUTSCH "Die Lambdaliste des Macros ~S enthält einen Punkt an falscher Stelle."
  323.                        #+ENGLISH "The lambda list of macro ~S contains a misplaced dot."
  324.                        #+FRANCAIS "La liste lambda du macro ~S contient un point mal placé."
  325.                        name
  326.               ))
  327.               ((eq (car listr) '&KEY) (analyze-key (cdr listr) restvar name))
  328.               ((eq (car listr) '&AUX) (analyze-aux (cdr listr) name))
  329.               (t (cerror #+DEUTSCH "Dieser ganze Teil wird ignoriert."
  330.                          #+ENGLISH "They will be ignored."
  331.                          #+FRANCAIS "Ignorer cette partie."
  332.                          #+DEUTSCH "Die Lambdaliste des Macros ~S enthält überflüssige Elemente: ~S"
  333.                          #+ENGLISH "The lambda list of macro ~S contains superfluous elements: ~S"
  334.                          #+FRANCAIS "La liste lambda du macro ~S contient des éléments superflus : ~S"
  335.                          name listr
  336.   ) ) ) )     )  )
  337. )
  338.  
  339. (%putd 'cons-car
  340.   (function cons-car
  341.     (lambda (exp &aux h)
  342.       (if
  343.         (and
  344.           (consp exp)
  345.           (setq h
  346.             (assoc (car exp)
  347.               '((car . caar) (cdr . cadr)
  348.                 (caar . caaar) (cadr . caadr) (cdar . cadar) (cddr . caddr)
  349.                 (caaar . caaaar) (caadr . caaadr) (cadar . caadar) (caddr . caaddr)
  350.                 (cdaar . cadaar) (cdadr . cadadr) (cddar . caddar) (cdddr . cadddr)
  351.                 (cddddr . fifth)
  352.         ) ) )  )
  353.         (cons (cdr h) (cdr exp))
  354.         (list 'car exp)
  355.   ) ) )
  356. )
  357.  
  358. (%putd 'cons-cdr
  359.   (function cons-cdr
  360.     (lambda (exp &aux h)
  361.       (if
  362.         (and
  363.           (consp exp)
  364.           (setq h
  365.             (assoc (car exp)
  366.               '((car . cdar) (cdr . cddr)
  367.                 (caar . cdaar) (cadr . cdadr) (cdar . cddar) (cddr . cdddr)
  368.                 (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar) (caddr . cdaddr)
  369.                 (cdaar . cddaar) (cdadr . cddadr) (cddar . cdddar) (cdddr . cddddr)
  370.         ) ) )  )
  371.         (cons (cdr h) (cdr exp))
  372.         (list 'cdr exp)
  373.   ) ) )
  374. )
  375.  
  376. (%putd 'analyze1
  377.   (function analyze1
  378.     (lambda (lambdalist accessexp name wholevar)
  379.       (do ((listr lambdalist (cdr listr))
  380.            (withinoptional nil)
  381.            (item)
  382.            (g))
  383.           ((atom listr)
  384.            (when listr
  385.              (unless (symbolp listr)
  386.                (error #+DEUTSCH "Die Lambdaliste des Macros ~S enthält eine unzulässige &REST-Variable: ~S"
  387.                       #+ENGLISH "The lambda list of macro ~S contains an illegal &REST variable: ~S"
  388.                       #+FRANCAIS "La liste lambda du macro ~S contient une variable &REST inadmissible : ~S"
  389.                       name listr
  390.              ) )
  391.              (setq %let-list (cons `(,listr ,accessexp) %let-list))
  392.              (setq %restp t)
  393.           ))
  394.         (setq item (car listr))
  395.         (cond ((eq item '&WHOLE)
  396.                (if (and wholevar (cdr listr) (symbolp (cadr listr)))
  397.                  (progn
  398.                    (setq %let-list (cons `(,(cadr listr) ,wholevar) %let-list))
  399.                    (setq listr (cdr listr))
  400.                  )
  401.                  (error #+DEUTSCH "Die Lambdaliste des Macros ~S enthält ein unzulässiges &WHOLE: ~S"
  402.                         #+ENGLISH "The lambda list of macro ~S contains an invalid &WHOLE: ~S"
  403.                         #+FRANCAIS "La liste lambda du macro ~S contient un &WHOLE inadmissible : ~S"
  404.                         name listr
  405.               )) )
  406.               ((eq item '&OPTIONAL)
  407.                (if withinoptional
  408.                  (cerror #+DEUTSCH "Es wird ignoriert."
  409.                          #+ENGLISH "It will be ignored."
  410.                          #+FRANCAIS "L'ignorer."
  411.                          #+DEUTSCH "Die Lambdaliste des Macros ~S enthält ein überflüssiges ~S."
  412.                          #+ENGLISH "The lambda list of macro ~S contains a superfluous ~S."
  413.                          #+FRANCAIS "La liste lambda du macro ~S contient un ~S superflu."
  414.                          name item
  415.                ) )
  416.                (setq withinoptional t)
  417.               )
  418.               ((or (eq item '&REST) (eq item '&BODY))
  419.                (return-from nil (analyze-rest (cdr listr) accessexp name))
  420.               )
  421.               ((eq item '&KEY)
  422.                (setq g (gensym))
  423.                (setq %restp t)
  424.                (setq %let-list (cons `(,g ,accessexp) %let-list))
  425.                (return-from nil (analyze-key (cdr listr) g name))
  426.               )
  427.               ((eq item '&ALLOW-OTHER-KEYS)
  428.                (cerror #+DEUTSCH "Es wird ignoriert."
  429.                        #+ENGLISH "It will be ignored."
  430.                        #+FRANCAIS "L'ignorer."
  431.                        #+DEUTSCH "Die Lambdaliste des Macros ~S enthält ~S vor &KEY."
  432.                        #+ENGLISH "The lambda list of macro ~S contains ~S before &KEY."
  433.                        #+FRANCAIS "La liste lambda du macro ~S contient ~S avant &KEY."
  434.                        name item
  435.               ))
  436.               ((eq item '&ENVIRONMENT)
  437.                (cerror #+DEUTSCH "Es wird ignoriert."
  438.                        #+ENGLISH "It will be ignored."
  439.                        #+FRANCAIS "L'ignorer."
  440.                        #+DEUTSCH "Die Lambdaliste des Macros ~S enthält ~S, was hier unzulässig ist."
  441.                        #+ENGLISH "The lambda list of macro ~S contains ~S which is illegal here."
  442.                        #+FRANCAIS "La liste lambda du macro ~S contient ~S qui est inadmissible ici."
  443.                        name item
  444.               ))
  445.               ((eq item '&AUX)
  446.                (return-from nil (analyze-aux (cdr listr) name))
  447.               )
  448.               (withinoptional
  449.                (setq %arg-count (1+ %arg-count))
  450.                (if %default-form
  451.                  (cond ((symbolp item) (setq item (list item %default-form)))
  452.                        ((and (consp item) (eql (length item) 1))
  453.                         (setq item (list (car item) %default-form))
  454.                ) )     )
  455.                (cond ((symbolp item)
  456.                       (setq %let-list (cons `(,item ,(cons-car accessexp)) %let-list))
  457.                      )
  458.                      ((atom item)
  459.                       #1=
  460.                       (error #+DEUTSCH "Die Lambdaliste des Macros ~S enthält ein unzulässiges Element: ~S"
  461.                              #+ENGLISH "The lambda list of macro ~S contains an invalid element ~S"
  462.                              #+FRANCAIS "La liste lambda du macro ~S contient un élément inadmissible : ~S"
  463.                              name item
  464.                      ))
  465.                      ((symbolp (car item))
  466.                       (setq %let-list
  467.                         (cons `(,(car item) (IF ,accessexp
  468.                                               ,(cons-car accessexp)
  469.                                               ,(if (consp (cdr item)) (cadr item) 'NIL)
  470.                                )            )
  471.                           %let-list
  472.                       ) )
  473.                       (when (and (consp (cdr item)) (consp (cddr item)))
  474.                         (unless (symbolp (caddr item))
  475.                           (error #+DEUTSCH "Die Lambdaliste des Macros ~S enthält eine unzulässige supplied-Variable: ~S"
  476.                                  #+ENGLISH "The lambda list of macro ~S contains an invalid supplied-variable ~S"
  477.                                  #+FRANCAIS "La liste lambda du macro ~S contient une «supplied-variable» indamissible : ~S"
  478.                                  name (caddr item)
  479.                         ) )
  480.                         (setq %let-list
  481.                           (cons `(,(caddr item) (NOT (NULL ,accessexp))) %let-list)
  482.                      )) )
  483.                      (t
  484.                       (setq g (gensym))
  485.                       (setq %let-list
  486.                         (cons `(,g ,(if (consp (cdr item))
  487.                                       `(IF ,accessexp
  488.                                          ,(cons-car accessexp)
  489.                                          ,(cadr item)
  490.                                        )
  491.                                       (cons-car accessexp)
  492.                                )    )
  493.                           %let-list
  494.                       ) )
  495.                       (let ((%min-args 0) (%arg-count 0) (%restp nil))
  496.                         (analyze1 (car item) g name g)
  497.                       )
  498.                       (if (consp (cddr item))
  499.                         (setq %let-list
  500.                           (cons `(,(caddr item) (NOT (NULL ,accessexp))) %let-list)
  501.                )     )) )
  502.                (setq accessexp (cons-cdr accessexp))
  503.               )
  504.               (t ; notwendige Argumente
  505.                (setq %min-args (1+ %min-args))
  506.                (setq %arg-count (1+ %arg-count))
  507.                (cond ((symbolp item)
  508.                       (setq %let-list (cons `(,item ,(cons-car accessexp)) %let-list))
  509.                      )
  510.                      ((atom item)
  511.                       #1# ; (error ... name item), s.o.
  512.                      )
  513.                      (t
  514.                       (let ((%min-args 0) (%arg-count 0) (%restp nil))
  515.                         (analyze1 item (cons-car accessexp) name (cons-car accessexp))
  516.                )     ))
  517.                (setq accessexp (cons-cdr accessexp))
  518.   ) ) ) )     )
  519. )
  520.  
  521. (%putd 'remove-env-arg
  522.   (function remove-env-arg
  523.     (lambda (lambdalist name)
  524.       (do ((listr lambdalist (cdr listr)))
  525.           ((atom listr) (values lambdalist nil))
  526.         (if (eq (car listr) '&ENVIRONMENT)
  527.           (if (and (consp (cdr listr)) (symbolp (cadr listr)) (cadr listr))
  528.             ; &ENVIRONMENT gefunden
  529.             (return
  530.               (values
  531.                 (do ((l1 lambdalist (cdr l1)) ; lambdalist ohne &ENVIRONMENT/Symbol
  532.                      (l2 nil (cons (car l1) l2)))
  533.                     ((eq (car l1) '&ENVIRONMENT)
  534.                      (nreconc l2 (cddr l1))
  535.                 )   )
  536.                 (cadr listr)
  537.             ) )
  538.             (error #+DEUTSCH "In der Lambdaliste des Macros ~S muß nach &ENVIRONMENT ein Symbol (nicht NIL) folgen: ~S"
  539.                    #+ENGLISH "In the lambda list of macro ~S, &ENVIRONMENT must be followed by a non-NIL symbol: ~S"
  540.                    #+FRANCAIS "Dans la liste lambda du macro ~S, &ENVIRONMENT doit être suivi par un symbole autre que NIL : ~S"
  541.                    name lambdalist
  542.           ) )
  543.   ) ) ) )
  544. )
  545.  
  546. (%putd 'make-length-test
  547.   (function make-length-test
  548.     (lambda (var)
  549.       (cond ((and (zerop %min-args) %restp) NIL)
  550.             ((zerop %min-args) `(> (LENGTH ,var) ,(1+ %arg-count)))
  551.             (%restp `(< (LENGTH ,var) ,(1+ %min-args)))
  552.             ((= %min-args %arg-count) `(/= (LENGTH ,var) ,(1+ %min-args)))
  553.             (t `(NOT (<= ,(1+ %min-args) (LENGTH ,var) ,(1+ %arg-count))))
  554.   ) ) )
  555. )
  556.  
  557. (%putd 'make-macro-expansion
  558.   (function make-macro-expansion
  559.     (lambda (macrodef)
  560.       (if (atom macrodef)
  561.         (error #+DEUTSCH "Daraus kann kein Macro definiert werden: ~S"
  562.                #+ENGLISH "Cannot define a macro from that: ~S"
  563.                #+FRANCAIS "Aucun macro n'est définissable à partir de ~S"
  564.                macrodef
  565.       ) )
  566.       (unless (symbolp (car macrodef))
  567.         (error #+DEUTSCH "Der Name eines Macros muß ein Symbol sein, nicht: ~S"
  568.                #+ENGLISH "The name of a macro must be a symbol, not ~S"
  569.                #+FRANCAIS "Le nom d'un macro doit être un symbole et non ~S"
  570.                (car macrodef)
  571.       ) )
  572.       (if (atom (cdr macrodef))
  573.         (error #+DEUTSCH "Der Macro ~S hat keine Lambdaliste."
  574.                #+ENGLISH "Macro ~S is missing a lambda list."
  575.                #+FRANCAIS "Le macro ~S ne possède pas de liste lambda."
  576.                (car macrodef)
  577.       ) )
  578.       (let ((name (car macrodef))
  579.             (lambdalist (cadr macrodef))
  580.             (body (cddr macrodef))
  581.            )
  582.         (multiple-value-bind (body-rest declarations docstring)
  583.                              (parse-body body t nil) ; globales Environment!
  584.           (if declarations (setq declarations (list (cons 'DECLARE declarations))))
  585.           (multiple-value-bind (newlambdalist envvar)
  586.                                (remove-env-arg lambdalist name)
  587.             (let ((%arg-count 0) (%min-args 0) (%restp nil)
  588.                   (%let-list nil) (%keyword-tests nil) (%default-form nil))
  589.               (analyze1 newlambdalist '(CDR <MACRO-FORM>) name '<MACRO-FORM>)
  590.               (let ((lengthtest (make-length-test '<MACRO-FORM>))
  591.                     (mainform `(LET* ,(nreverse %let-list)
  592.                                  ,@declarations
  593.                                  ,@(nreverse %keyword-tests)
  594.                                  ,@body-rest
  595.                    ))          )
  596.                 (if lengthtest
  597.                   (setq mainform
  598.                     `(IF ,lengthtest
  599.                        (MACRO-CALL-ERROR <MACRO-FORM>)
  600.                        ,mainform
  601.                 ) )  )
  602.                 (values
  603.                   `(FUNCTION ,name
  604.                      (LAMBDA (<MACRO-FORM> &OPTIONAL ,(or envvar '<ENV-ARG>))
  605.                        (DECLARE (CONS <MACRO-FORM>))
  606.                        ,@(unless envvar '((DECLARE (IGNORE <ENV-ARG>))))
  607.                        ,@(if docstring (list docstring))
  608.                        (BLOCK ,name ,mainform)
  609.                    ) )
  610.                   name
  611.                   lambdalist
  612.                   docstring
  613.   ) ) ) ) ) ) ) )
  614. )
  615.  
  616.